home *** CD-ROM | disk | FTP | other *** search
/ The Original Shareware 1.1 / The Original Shareware (WeMake CDs)(Volume 1.1)(CDs, Inc)(1993).iso / 2 / qbscreen.zip / SCREEN.BAS < prev    next >
BASIC Source File  |  1986-12-16  |  10KB  |  251 lines
  1.  
  2.       REM SCREEN.BAS V1.0 (12/15/86)
  3.  
  4.       REM $INCLUDE: 'LISTING.BAS'
  5.       DEFINT A-Z
  6.       REM $INCLUDE: 'SUBDIM.BAS'
  7.       REM $INCLUDE: 'SHARED.BAS'
  8.  
  9. SUB CHGATTR (ROW,SCOL,ECOL,ATTR) STATIC
  10.       DEF SEG=&H40
  11.       REM IF CRT = 1  THEN 40 X 25 COLOR
  12.       REM IF CRT = 32 THEN 80 X 25 COLOR
  13.       REM IF CRT = 48 THEN MONOCHROME
  14.       REM IF CRT = 64 THEN BOTH
  15.       CRT = PEEK(&H10)
  16.         IF CRT = 48 THEN DEF SEG=&HB000 ELSE DEF SEG=&HB800
  17.         PT = ((ROW-1)*160) + ((SCOL-1)*2) + 1
  18.         FOR N = 1 TO (ECOL-SCOL+1)
  19.         POKE PT+((N-1)*2),ATTR
  20.         NEXT N
  21. END SUB
  22.  
  23. SUB FUNCTIONS (FLD$) STATIC
  24.       KEY OFF
  25.       FOR N = 1 TO 10
  26.       KEY N,""
  27.       NEXT N
  28.       AB=1 :COL=1 :N=1
  29.       LOCATE 25,1 : PRINT SPC(72);
  30. 50    WHILE AB<LEN(FLD$)
  31.       IF MID$(FLD$,AB,1)="," THEN AB=AB+1 : N=N+1 : GOTO 50
  32.       AE=((INSTR(AB,FLD$,","))-AB)
  33.       IF AE <= 0 THEN AE=LEN(FLD$)+1-AB
  34.       LOCATE 25,COL : COLOR SFG,SBG : PRINT "[F";LEFT$((MKI$(N+48)),1);"]"; : COLOR RFG,RBG : PRINT MID$(FLD$,AB,AE); : COLOR SFG,SBG
  35.       L=LEN(MID$(FLD$,AB,AE)) : AB=AB+L+1 : N=N+1 : COL=COL+L+6
  36.       WEND
  37.       COLOR FG,BG
  38. END SUB
  39. SUB ACCEPT (FLD$,F$) STATIC
  40.       CALL LODARG (FLD$,N)
  41.       IF LEFT$((ARG$(1)),1) = ";" THEN F$="" : KY=0 : EXIT SUB
  42.       YES = NOT NO : NO = NOT YES
  43.       IF INSTR(1,ARG$(3),"LCK")   THEN KY=0 : EXIT SUB
  44.       IF INSTR(1,ARG$(3),"ALP")   THEN AP=YES ELSE AP=NO
  45.       IF INSTR(1,ARG$(3),"CAP")   THEN CP=YES ELSE CP=NO
  46.       IF INSTR(1,ARG$(3),"NUM")   THEN NM=YES ELSE NM=NO
  47.       IF INSTR(1,ARG$(3),"NODEF") THEN DF=NO  ELSE DF=YES
  48.       IF INSTR(1,ARG$(3),"FIX")   THEN FX=YES ELSE FX=NO
  49.       IF INSTR(1,ARG$(3),"DEC")   THEN DC=YES ELSE DC=NO
  50.       IF INSTR(1,ARG$(3),"REV")   THEN RV=YES ELSE RV=NO
  51.       IF INSTR(1,ARG$(5),"YES") OR EDITMODE=YES THEN ED=YES ELSE ED=NO
  52.       IF DC THEN DEF$="   " ELSE DEF$=" "
  53.       IF NM AND NOT DC AND DF THEN DEF$="0"
  54.       IF NM AND     DC AND DF THEN DEF$="0.00"
  55.       FL=VAL(ARG$(4))
  56.       IF VAL(ARG$(1))<>0 THEN LOCATE VAL(ARG$(1)),VAL(ARG$(2)) ELSE LOCATE ,VAL(ARG$(2))
  57.       ON ERROR GOTO INPERR
  58.       GOSUB GETINP
  59.       ON ERROR GOTO 0
  60.       EXIT SUB
  61. GETINP:
  62.       REM F$ = FIELD/PROMPT TO BE DISPLAYED
  63.       REM FL = FIELD LENGTH
  64.       REM WL = CHARACTER COUNT
  65.       REM WI = COLUMN POINTER
  66.       REM QY = CURRENT LINE
  67.       REM QX = CURRENT COLUMN
  68.       REM DP = DECIMAL COUNT
  69.       REM ES = ERROR SWITCH
  70.       REM W$ = INPUT CHARACTER
  71.       REM KY = FUNCTION/CONTROL KEY ENTERED
  72. 100   DP=0: WL=0: WI=1: IN$=INKEY$ : TRANSFER=NO : BYTS!=FRE("")
  73.       QX= POS(0):  QY=CSRLIN
  74.       IN$= SPACE$(FL)
  75.       IF NOT DF         THEN 590
  76.       IF F$="" OR F$=SPACE$(FL+DC) THEN 490
  77.       IF NOT DC         THEN 470
  78.       IN$=LEFT$(F$,FL-3)+"."+RIGHT$(F$,2) : WL=LEN(IN$) : GOTO 490
  79. 470   IN$= LEFT$(F$+SPACE$(FL),FL):  WL=LEN(F$)
  80. 480   IF MID$(IN$,WL,1)=" " THEN WL=WL-1:  IF WL>0 THEN 480
  81. 490   IF RV THEN COLOR RFG,RBG ELSE COLOR FG,BG
  82.       LOCATE QY,QX,1: PRINT IN$;
  83. 510   LOCATE QY,QX+WI-1
  84. 520   W$=INKEY$: DEF SEG=&H40: QK=PEEK(&H17) AND 96:
  85.       IF QK1<>QK THEN LOCATE 25,73: COLOR RFG,RBG : PRINT LOCKS$(QK/32);: QK1=QK: SOUND 400+QK,.3: GOTO 590
  86.       IF DATSW THEN CALL DISDATE
  87.       IF W$=""          THEN 520
  88.       KY=0
  89.       IF ES             THEN LOCATE 24,1 : PRINT SPC(40); : COLOR FG,BG : LOCATE QY,QX+WI-1 : ES=NO : IF RV THEN COLOR RFG,RBG
  90.       IF LEN(W$)=1      THEN 660  ELSE  KY= ASC(RIGHT$(W$,1))
  91.       IF KY>=F1 AND KY<=F10 THEN RETURN
  92.       IF KY= CTRL.RT    THEN 860
  93.       IF KY= CTRL.LF    THEN 860
  94.       IF KY= PG.UP      THEN 860
  95.       IF KY= PG.DN      THEN 860
  96.       IF NOT AP         THEN 520
  97.       IF KY= INS.KEY    THEN IF INSERT=NO THEN INSERT=YES: LOCATE,,,CU1,CU2: GOTO 490 ELSE INSERT=NO:  LOCATE,,,CU2: GOTO 520
  98.       IF KY= RT.CURSOR  THEN WI=WI-(WI<(WL+1)): GOTO 510
  99.       IF KY= LF.CURSOR  THEN WI=WI+(WI> 1): GOTO 510
  100.       IF KY= DEL.KEY    THEN IF WL<>0 AND WI<=FL AND WL>=WI THEN IN$= LEFT$(IN$,WI-1)+RIGHT$(IN$,FL-WI)+" ": WL=WL-1: GOTO 490
  101.       IF INSERT         THEN INSERT=NO: LOCATE,,,CU2
  102.       IF KY= CTRL.HOME  THEN WI=1: GOTO 510
  103.       IF KY= CTRL.END   THEN WI= WL+1:  GOTO 510
  104.       IF KY= HOME       THEN IN$=LEFT$(IN$,WI-1)+SPACE$(FL-WI+1): WL=WI-1: GOTO 490
  105.                            GOTO 510
  106. 590   IF RV THEN COLOR RFG,RBG ELSE COLOR FG,BG
  107.                            GOTO 510
  108. 660   IF W$= NTR$       THEN 860
  109.       IF W$= ESC$       THEN KY=ESC : GOTO 940
  110.       IF WI>FL          THEN IF W$<> BKSP$ THEN ERROR 101 : GOTO 510
  111. 730   IF AP AND NOT CP  THEN IF W$>=" " AND W$<="~" THEN 750
  112.       IF NM             THEN IF W$>="0" AND W$<="9" THEN 750
  113.       IF NM             THEN IF WI=1 AND W$="-" THEN 750
  114.       IF DC             THEN IF W$="." AND DP=0 THEN DP=1 : GOTO 770
  115.       IF AP AND CP      THEN IF W$>="a" AND W$<="z" THEN W$=CHR$(ASC(W$)-32): GOTO 750  ELSE IF W$>=" " AND W$<"a" THEN 750
  116.       IF W$=BKSP$       THEN IF WI>1 THEN IN$=LEFT$(IN$,WI-2)+RIGHT$(IN$,FL-WI+1)+" ": WL=WL-1: WI=WI-1: DP=DP+(DP>0):LOCATE ,QX+WI-1: PRINT " ";: GOTO 510
  117.       IF NM             THEN IF W$<>BKSP$ THEN ERROR 103
  118.       GOTO 510
  119. 750   IF NOT DC         THEN 770 ELSE IF DP=0 AND W$<>"." AND WI=FL-2  THEN 520
  120.       IF DP=0           THEN 770 ELSE IF DP=3 THEN 520 ELSE DP=DP+1
  121. 770   IF NOT INSERT     THEN MID$(IN$,WI,1)=W$: TRANSFER=YES : GOTO 790
  122.       IF WL < FL        THEN WL=WL+1: IN$= LEFT$( LEFT$(IN$,WI-1) +W$ +RIGHT$(IN$,FL-WI+1), FL): WI=WI+1 : TRANSFER=YES : GOTO 490  ELSE 520
  123. 790   IF WI>1           THEN 820
  124.       IN$=W$+SPACE$(FL-1) : IF W$<>"." THEN DP=0
  125.       LOCATE,QX: PRINT IN$;: LOCATE,QX: WL=1
  126. 820   PRINT W$;
  127.       WI=WI+1: IF WI>WL THEN WL=WI-1
  128.       IF FL>1 OR WL<FL  THEN 520
  129. 860   COLOR FG,BG:  LOCATE QY,QX,,CU2: INSERT=NO
  130.       IF KY<>0          THEN 960
  131.       IF WL=0 AND NOT ED THEN ERROR 102 : GOTO 510
  132.       IF FX   AND WL<>0 AND WL<FL   THEN ERROR 104 : GOTO 510
  133.       IF NOT TRANSFER AND ((WL=0 AND EDITMODE) OR (WL<>0)) THEN 950
  134.       IF DC THEN 900
  135.       IF NM THEN 930
  136.       IN$= LEFT$(IN$+SPACE$(FL),FL):  GOTO 935
  137. 900   WHILE LEFT$(IN$,1)="0"
  138.       IN$=RIGHT$(IN$,FL-1)+" " : WL=WL-1
  139.       WEND
  140.       IF WL>0           THEN IN$=LEFT$(IN$,WL)+MID$(".00",DP+1,3-DP) ELSE IN$=DEF$ : WL=4 : DP=3
  141.       IN$=SPACE$(FL-WL-(3-DP))+IN$: PRINT IN$;
  142.       IN$=LEFT$(IN$,FL-3)+RIGHT$(IN$,2): F$=IN$ : RETURN
  143. 930   WHILE LEFT$(IN$,1)="0"
  144.       IN$=RIGHT$(IN$,FL-1)+" " : WL=WL-1
  145.       WEND
  146.       IF WL>0           THEN IN$=SPACE$(FL-WL)+LEFT$(IN$,WL) ELSE IN$=SPACE$(FL-1)+DEF$
  147. 935   F$=IN$
  148. 940   PRINT IN$;
  149. 950   RETURN
  150.  
  151. 960   IF WL<>0 AND F$="" THEN 510
  152.       IF KY<>CTRL.LF AND NOT ED THEN ERROR 102 : GOTO 510
  153.       IN$= SPACE$(FL)
  154.       IF F$=""            THEN 940
  155.       IF NOT DC           THEN 970
  156.       IF F$<>SPACE$(FL-1) THEN IN$=LEFT$(F$,FL-3)+"."+RIGHT$(F$,2) : GOTO 940
  157. 970   IN$= LEFT$(F$+SPACE$(FL),FL) : GOTO 940
  158. END SUB
  159. INPERR:
  160.       CALL DISERR (ERR,ER$)
  161.       RESUME NEXT
  162. SUB DISERR (EN,ER$) STATIC
  163.       COLOR HL,BG: LOCATE 24,1 : PRINT SPC(40); : BEEP : ES=YES : LOCATE ,1
  164.       IF EN<100         THEN PRINT "BASIC ERROR ="EN "LINE ="ERL;
  165.       IF EN>200         THEN COLOR BL : PRINT ER$;
  166.       IF EN=101         THEN PRINT "<<FIELD OVERFLOW>>";
  167.       IF EN=102         THEN PRINT "<<CAN'T OMIT>>";
  168.       IF EN=103         THEN PRINT "<<NON-NUMERIC>>";
  169.       IF EN=104         THEN PRINT "<<FIXED LENGTH INPUT>>";
  170.       IF EN=105         THEN PRINT "<<INVALID NUMBER>>";
  171.       IF EN=106         THEN PRINT "<<ENTRY ***VOIDED*** >>";
  172.  
  173.       IF EN=111         THEN PRINT "[RECORD NOT FOUND]";
  174.       IF EN=112         THEN PRINT "[END OF FILE]";
  175.       IF EN=113         THEN PRINT "[PARTIAL MATCH FOUND]";
  176.       IF EN=115         THEN PRINT "[INSUFFICIENT KEY INPUT]";
  177.       COLOR FG,BG
  178. END SUB
  179. SUB ASKUM (QUEST$,ANS$) STATIC
  180.       COLOR HL,BG : LOCATE 24,1 : PRINT SPC(80); : BEEP
  181.       PRINT QUEST$;"? [Y,N] <DEFAULT=N>:";
  182.       ANS$=""
  183.       WHILE ANS$=""
  184.       ANS$=INKEY$
  185.       WEND
  186.       LOCATE 24,1 : PRINT SPC(80);
  187.       IF (ANS$<>"Y" AND ANS$<>"y") THEN ANS$="N"
  188.       COLOR FG,BG
  189. END SUB
  190. SUB DISDATE STATIC
  191.      STATIC TIM$
  192.      IF LEFT$(TIM$,5)=LEFT$(TIME$,5) OR NOT DATSW THEN EXIT SUB
  193.      CX=CSRLIN : CY=POS(0)
  194.      DAT$=DATE$:TIM$=TIME$:X=VAL(TIM$):IF X>11 THEN CH$=" pm":X=X\13+X MOD 13 ELSE CH$=" am":IF X=0 THEN X=12
  195.      MSG$="Date: "+MID$("JanFebMarAprMayJunJulAugSepOctNovDec",3*VAL(DAT$)-2,3)+STR$(VAL(MID$(DAT$,4)))+", "+RIGHT$(DAT$,4)+"     Time:"+STR$(X)+MID$(TIM$,3,3)+CH$
  196.      COLOR HL,BG : LOCATE 1,22 : PRINT MSG$; : LOCATE CX,CY : COLOR FG,BG
  197. END SUB
  198. SUB DISPBIN (FLD$,BDATA,BUMP) STATIC
  199.       DATA$=STR$(BDATA)
  200.       CALL DISPLAY (FLD$,DATA$,BUMP)
  201. END SUB
  202. SUB DISPLAY (FLD$,DATA$,BUMP) STATIC
  203.       CALL LODARG (FLD$,N)
  204.       IF LEFT$((ARG$(1)),1) = ";" THEN EXIT SUB
  205.       LOCATE VAL(ARG$(1))+BUMP,VAL(ARG$(2))
  206.       IF INSTR(1,ARG$(3),"BLINK") THEN COLOR BL,BG
  207.       IF INSTR(1,ARG$(3),"REV")   THEN COLOR RFG,RBG
  208.       IF INSTR(1,ARG$(3),"HIGH")  THEN COLOR HL,BG
  209.  
  210.       IF DATA$="" THEN PRINT ARG$(4) : COLOR FG,BG : EXIT SUB
  211.       YES = NOT NO : NO = NOT YES
  212.       IF INSTR(1,ARG$(3),"ALP") THEN AP=YES ELSE AP=NO
  213.       IF INSTR(1,ARG$(3),"BIN") THEN BN=YES ELSE BN=NO
  214.       IF INSTR(1,ARG$(3),"NUM") THEN NM=YES ELSE NM=NO
  215.       IF INSTR(1,ARG$(3),"DEC") THEN DC=YES ELSE DC=NO
  216.       FL=VAL(ARG$(4))
  217.       IF BN THEN PRINT RIGHT$(SPACE$(FL)+DATA$,FL);
  218.       IF DC AND DATA$=SPACE$(FL-1) THEN PRINT DATA$; : COLOR FG,BG : EXIT SUB
  219.       IF DC THEN PRINT LEFT$(DATA$,FL-3)+"."+RIGHT$(DATA$,2);
  220.       IF (NOT DC) AND (NOT BN) THEN PRINT DATA$;
  221.       COLOR FG,BG
  222. END SUB
  223. SUB LODARG (FLD$,N) STATIC
  224.       AB=1 : AE=1 : N=0
  225.       WHILE AE>0
  226.       AE=INSTR(AB,FLD$,",")
  227.       N=N+1
  228.       IF AE>0 THEN ARG$(N) = MID$(FLD$,AB,AE-AB) ELSE ARG$(N) = MID$(FLD$,AB)
  229.       AB=AE+1
  230.       WEND
  231. END SUB
  232. SUB LODWK1 (FLD$,N) STATIC
  233.       AB=1 : AE=1 : N=0
  234.       WHILE AE>0
  235.       AE=INSTR(AB,FLD$,",")
  236.       N=N+1
  237.       IF AE>0 THEN WRK1%(N) = VAL(MID$(FLD$,AB,AE-AB)) ELSE WRK1%(N) = VAL(MID$(FLD$,AB))
  238.       AB=AE+1
  239.       WEND
  240. END SUB
  241. SUB LODWK2 (FLD$,N) STATIC
  242.       AB=1 : AE=1 : N=0
  243.       WHILE AE>0
  244.       AE=INSTR(AB,FLD$,",")
  245.       N=N+1
  246.       IF AE>0 THEN WRK2%(N) = VAL(MID$(FLD$,AB,AE-AB)) ELSE WRK2%(N) = VAL(MID$(FLD$,AB))
  247.       AB=AE+1
  248.       WEND
  249. END SUB
  250.  
  251.